- QAQAUTL ;HISC/DDA,DAD-UTILITY FOR QUALITY ASSURANCE MODULE ;7/12/93 14:16
- ;;1.7;QM Integration Module;;07/25/1995
- EN1 ; INPUT TRANSFORM ON FIELDS #741.05 & 743.02 OF FILE #740
- ; FREE TEXT POINTER TO DEVICE FILE. ALLOWS ONLY DEVICES WITH TERMINAL
- ; TYPES OF 'P-' OR 'PK-'. STORED AS: DEVICE;IOST;IOM;IOSL.
- S DIC("S")="I $E($G(^%ZIS(2,+$G(^%ZIS(1,+Y,""SUBTYPE"")),0)))=""P"""
- S DIC="^%ZIS(1,",DIC(0)="EMQ" D ^DIC K DIC S X=$P(Y,"^",2) S:$D(DIE)#2 DIC=DIE G:Y<0 1
- K %ZIS S %ZIS="NQ",(IOP,QAQA)=X D ^%ZIS S:POP Y=-1 S X=QAQA_";"_$S($D(IOST)#2:IOST,1:"")_";"_$S($D(IOM)#2:IOM,1:"")_";"_$S($D(IOSL)#2:IOSL,1:"")
- 1 K %ZIS,IOP,QAQA Q
- EN2 ; ENTRY POINT FOR OUTPUT TRANSFORM ON FIELD #.02 OF FILE #740.5
- ; DISPLAYS FIELD #.01 ENTRY IN THE POINTED TO FILE
- S QAQADICT=^QA(740.5,D0,0),QAQAFLD=$P(QAQADICT,"^",2),QAQADICT=+QAQADICT
- Q:$D(^DIC(QAQADICT,0,"GL"))[0
- S Y=$S(Y'>0:Y,$D(@(^DIC(QAQADICT,0,"GL")_Y_",0)"))#2:$P(^(0),"^"),1:Y)
- S C=$P(^DD(QAQADICT,.01,0),"^",2) D Y^DIQ S Y=QAQAFLD_" "_Y
- K QAQADICT,QAQAFLD
- Q
- EN3(FILE,FIELD) ; ENTRY POINT FOR XECUTABLE HELP ON DEVICE FREE TEXT POINTER
- ; FIELDS: DISPLAYS THE FIELD DESCRIPTION AND DEVICES
- I $D(DZ)#2,DZ?1"?" G 3
- F QAQA=0:0 S QAQA=$O(^DD(FILE,FIELD,21,QAQA)) Q:QAQA'>0 W:$D(^DD(FILE,FIELD,21,QAQA,0))#2 !,^(0)
- W !
- 3 S DIC="^%ZIS(1,",DIC(0)="M",DIC("W")="S QAQA=$S($D(^(1)):"" ""_^(1),1:"""") W:$X+$L(X)>78 !?79-$L(X) W $P(QAQA,""^""),"" "",$P(^(0),""^"",2),"" "",$P(^(0),""^"",9)",D="B",DZ="?"
- D DQ^DICQ K DIC S DIC=DIE
- K QAQA Q
- EN5 ; *** INPUT TRANSFORM ON FIELD 740,743.05
- S QAM="2359-2359" F QA=1,3,6,8 I $E(X,QA,QA+1)>$E(QAM,QA,QA+1) K X Q
- I $D(X) K:$P(X,"-",2)'>$P(X,"-") X
- K QA,QAM Q
- EN6 ;*** CONFIDENTIALITY STATEMENT ***
- W !!,"** This information is confidential in accordance with Title 38 U.S.C. 5705 **",!
- Q
- EN7 ;*** PRIVACY STATEMENT ***
- W !!,"* This info is provided only for the purposes described in 38 U.S.C. 3301 (F) *",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQAUTL 1963 printed Jan 18, 2025@03:32:31 Page 2
- QAQAUTL ;HISC/DDA,DAD-UTILITY FOR QUALITY ASSURANCE MODULE ;7/12/93 14:16
- +1 ;;1.7;QM Integration Module;;07/25/1995
- EN1 ; INPUT TRANSFORM ON FIELDS #741.05 & 743.02 OF FILE #740
- +1 ; FREE TEXT POINTER TO DEVICE FILE. ALLOWS ONLY DEVICES WITH TERMINAL
- +2 ; TYPES OF 'P-' OR 'PK-'. STORED AS: DEVICE;IOST;IOM;IOSL.
- +3 SET DIC("S")="I $E($G(^%ZIS(2,+$G(^%ZIS(1,+Y,""SUBTYPE"")),0)))=""P"""
- +4 SET DIC="^%ZIS(1,"
- SET DIC(0)="EMQ"
- DO ^DIC
- KILL DIC
- SET X=$PIECE(Y,"^",2)
- if $DATA(DIE)#2
- SET DIC=DIE
- if Y<0
- GOTO 1
- +5 KILL %ZIS
- SET %ZIS="NQ"
- SET (IOP,QAQA)=X
- DO ^%ZIS
- if POP
- SET Y=-1
- SET X=QAQA_";"_$SELECT($DATA(IOST)#2:IOST,1:"")_";"_$SELECT($DATA(IOM)#2:IOM,1:"")_";"_$SELECT($DATA(IOSL)#2:IOSL,1:"")
- 1 KILL %ZIS,IOP,QAQA
- QUIT
- EN2 ; ENTRY POINT FOR OUTPUT TRANSFORM ON FIELD #.02 OF FILE #740.5
- +1 ; DISPLAYS FIELD #.01 ENTRY IN THE POINTED TO FILE
- +2 SET QAQADICT=^QA(740.5,D0,0)
- SET QAQAFLD=$PIECE(QAQADICT,"^",2)
- SET QAQADICT=+QAQADICT
- +3 if $DATA(^DIC(QAQADICT,0,"GL"))[0
- QUIT
- +4 SET Y=$SELECT(Y'>0:Y,$DATA(@(^DIC(QAQADICT,0,"GL")_Y_",0)"))#2:$PIECE(^(0),"^"),1:Y)
- +5 SET C=$PIECE(^DD(QAQADICT,.01,0),"^",2)
- DO Y^DIQ
- SET Y=QAQAFLD_" "_Y
- +6 KILL QAQADICT,QAQAFLD
- +7 QUIT
- EN3(FILE,FIELD) ; ENTRY POINT FOR XECUTABLE HELP ON DEVICE FREE TEXT POINTER
- +1 ; FIELDS: DISPLAYS THE FIELD DESCRIPTION AND DEVICES
- +2 IF $DATA(DZ)#2
- IF DZ?1"?"
- GOTO 3
- +3 FOR QAQA=0:0
- SET QAQA=$ORDER(^DD(FILE,FIELD,21,QAQA))
- if QAQA'>0
- QUIT
- if $DATA(^DD(FILE,FIELD,21,QAQA,0))#2
- WRITE !,^(0)
- +4 WRITE !
- 3 SET DIC="^%ZIS(1,"
- SET DIC(0)="M"
- SET DIC("W")="S QAQA=$S($D(^(1)):"" ""_^(1),1:"""") W:$X+$L(X)>78 !?79-$L(X) W $P(QAQA,""^""),"" "",$P(^(0),""^"",2),"" "",$P(^(0),""^"",9)"
- SET D="B"
- SET DZ="?"
- +1 DO DQ^DICQ
- KILL DIC
- SET DIC=DIE
- +2 KILL QAQA
- QUIT
- EN5 ; *** INPUT TRANSFORM ON FIELD 740,743.05
- +1 SET QAM="2359-2359"
- FOR QA=1,3,6,8
- IF $EXTRACT(X,QA,QA+1)>$EXTRACT(QAM,QA,QA+1)
- KILL X
- QUIT
- +2 IF $DATA(X)
- if $PIECE(X,"-",2)'>$PIECE(X,"-")
- KILL X
- +3 KILL QA,QAM
- QUIT
- EN6 ;*** CONFIDENTIALITY STATEMENT ***
- +1 WRITE !!,"** This information is confidential in accordance with Title 38 U.S.C. 5705 **",!
- +2 QUIT
- EN7 ;*** PRIVACY STATEMENT ***
- +1 WRITE !!,"* This info is provided only for the purposes described in 38 U.S.C. 3301 (F) *",!
- +2 QUIT