- QAMUTL0 ;HISC/DAD-MONITORING TOOL UTILITIES ;10/22/93 08:34
- ;;1.0;Clinical Monitoring System;**1**;09/13/1993
- EN1 ; *** CHECKS FOR A VALID RELATIONSHIP AMONG THE CONDITIONS
- ; *** USED BY FIELD: 743,25
- N C S QAM("X")=X G:$TR(X,"(C!'&0123456789)")]"" XBAD1 G:X?1.N XBAD1
- S X="I "_QAM("X") D ^DIM G:'$D(X) XBAD1 S QAM("C")=""
- F QAM=0:0 S QAM=$O(^QA(743,D0,"COND",QAM)) Q:QAM'>0 S @("C"_QAM_"=1") S QAM("C")=QAM("C")_"C"_QAM_"^"
- S X="XBAD1^QAMUTL0",@^%ZOSF("TRAP") S X="I "_QAM("X") X X
- ;F QAM=1:1 Q:$P(QAM("C"),"^",QAM)="" G:X'[$P(QAM("C"),"^",QAM) XBAD1
- XOK1 S X="",@^%ZOSF("TRAP"),X=QAM("X") K QAM G 1
- XBAD1 S X="",@^%ZOSF("TRAP") K QAM,X
- 1 F QAM=0:0 S QAM=$O(^QA(743,D0,"COND",QAM)) Q:QAM'>0 K @("C"_QAM)
- Q
- EN2 ; *** DISPLAY HELP SCREEN OF CONDITIONS
- ; *** USED BEFORE EDIT OF FALL OUT RELATIONSHIP FIELD (743,25)
- Q:$D(^QA(743,DA,"COND",0))[0 Q:$P(^(0),"^",4)'>0
- W !!?3,"CODE",?15,"CONDITION",!?2,"------",?14,"-----------"
- F QAMD1=0:0 S QAMD1=$O(^QA(743,DA,"COND",QAMD1)) Q:QAMD1'>0 S QAM=$S($D(^QA(743,DA,"COND",QAMD1,0))#2:+^(0),1:0),QAM=$S($D(^QA(743.3,QAM,0))#2:$P(^(0),"^"),1:"") W !?3,$J("C"_QAMD1,3),?15,QAM
- W !
- Q
- EN3 ; *** ASK PARAMETERS ON CONDITIONS
- ; *** USED BY ALL EDITS ON THE CONDITION MULTIPLE
- K Y
- S QAM=+$S($D(^QA(743,QAMD0,"COND",QAMD1,0))#2:^(0),1:0) Q:QAM'>0
- Q:$P($G(^QA(743.3,QAM,0)),"^",2)'>0
- S QAMPCODE=$S($D(^QA(743.3,QAM,"PARM"))#2:^("PARM"),1:"") Q:QAMPCODE=""
- S X=$P(QAMPCODE,"^",$L(QAMPCODE,"^")) X ^%ZOSF("TEST") I X QAMPCODE
- Q
- EN4 ; *** CHECKS FOR A VALID RELATIONSHIP AMONG THE CONDITIONS
- ; *** USED BY FIELD: 743,26
- Q:'$D(^QA(743,D0,"COND","AS",1))
- N C S QAM("X")=X G:$TR(X,"(C!'&0123456789)")]"" XBAD4 G:X?1.N XBAD4
- S X="I "_QAM("X") D ^DIM G:'$D(X) XBAD4 S QAM("C")=""
- F QAM=0:0 S QAM=$O(^QA(743,D0,"COND",QAM)) Q:QAM'>0 I $P(^QA(743,D0,"COND",QAM,0),"^",2) S @("C"_QAM_"=1") S QAM("C")=QAM("C")_"C"_QAM_"^"
- S X="XBAD4^QAMUTL0",@^%ZOSF("TRAP") S X="I "_QAM("X") X X
- ;F QAM=1:1 Q:$P(QAM("C"),"^",QAM)="" G:X'[$P(QAM("C"),"^",QAM) XBAD4
- XOK4 S X="",@^%ZOSF("TRAP"),X=QAM("X") K QAM G 4
- XBAD4 S X="",@^%ZOSF("TRAP") K QAM,X
- 4 F QAM=0:0 S QAM=$O(^QA(743,D0,"COND",QAM)) Q:QAM'>0 K @("C"_QAM)
- Q
- EN5 ; *** DISPLAY HELP SCREEN OF CONDITIONS
- ; *** USED BEFORE EDIT OF SAMPLE RELATIONSHIP FIELD (743,26)
- Q:$D(^QA(743,DA,"COND",0))[0 Q:$P(^(0),"^",4)'>0 Q:'$D(^QA(743,DA,"COND","AS",1))
- W !!?3,"CODE",?15,"CONDITION",!?2,"------",?14,"-----------"
- F QAMD1=0:0 S QAMD1=$O(^QA(743,DA,"COND",QAMD1)) Q:QAMD1'>0 S QAM=$S($D(^QA(743,DA,"COND",QAMD1,0))#2:^(0),1:0) I $P(QAM,"^",2) S QAM=$S($D(^QA(743.3,+QAM,0))#2:$P(^(0),"^"),1:"") W !?3,$J("C"_QAMD1,3),?15,QAM
- W !
- Q
- EN6 ; *** MOST RECENT PATIENT MOVEMENT (FILE #405)
- ; *** USED AS DATA BY FIELD 743.4,40
- ; PUT MOST DESIRED TRANSACTION TYPES AT THE BEGINNING OF QAMXREF E.G.
- ; QAMXREF="6^2^1^3" SCAN: SPECIALTY XFR, WARD XFR, ADMISSION, DISCHARGE
- S QAMDTPT(1)=0 Q:$D(QAMXREF)[0
- F QA=1:1:$L(QAMXREF,"^") S QA(0)=$P(QAMXREF,"^",QA),QAM=+$O(^DGPM("ATID"_QA(0),QAMDFN,9999999.9999998-QAMEVENT)),QAMDTPT(1)=+$O(^DGPM("ATID"_QA(0),QAMDFN,QAM,0)) Q:QAMDTPT(1)
- K QAMXREF Q
- EN7 ; *** SCREEN FOR OTHER DATA TO CAPTURE, USED BY FIELD 743,30
- I 0
- F QA=0:0 S QA=$O(^QA(743.3,"AELEM",+Y,QA)) Q:QA'>0 I $O(^QA(743,D0,"COND","B",QA,0))>0 Q
- K QA Q
- EN8 ; *** INPUT TRANSFORM FOR GROUP MEMBER SUB-FIELD 743.51,.01
- N D,DIC,DICR,DIX,DO,Y S X=$S(X[";":$P(X,";"),1:X),Y=-1,DIC(0)="EMQZ",DIC=$S($D(^QA(743.5,DA(1),0))#2:+$P(^(0),"^",2),1:0),DIC=$S($D(^DIC(DIC,0,"GL"))#2:^("GL"),1:"") G:DIC="" 8 D DO^DIC1,^DIC S X=$S($D(Y(0,0))#2:Y(0,0)_";"_+Y,1:"")
- 8 K:Y'>0 X Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMUTL0 3631 printed Feb 18, 2025@23:09:07 Page 2
- QAMUTL0 ;HISC/DAD-MONITORING TOOL UTILITIES ;10/22/93 08:34
- +1 ;;1.0;Clinical Monitoring System;**1**;09/13/1993
- EN1 ; *** CHECKS FOR A VALID RELATIONSHIP AMONG THE CONDITIONS
- +1 ; *** USED BY FIELD: 743,25
- +2 NEW C
- SET QAM("X")=X
- if $TRANSLATE(X,"(C!'&0123456789)")]""
- GOTO XBAD1
- if X?1.N
- GOTO XBAD1
- +3 SET X="I "_QAM("X")
- DO ^DIM
- if '$DATA(X)
- GOTO XBAD1
- SET QAM("C")=""
- +4 FOR QAM=0:0
- SET QAM=$ORDER(^QA(743,D0,"COND",QAM))
- if QAM'>0
- QUIT
- SET @("C"_QAM_"=1")
- SET QAM("C")=QAM("C")_"C"_QAM_"^"
- +5 SET X="XBAD1^QAMUTL0"
- SET @^%ZOSF("TRAP")
- SET X="I "_QAM("X")
- XECUTE X
- +6 ;F QAM=1:1 Q:$P(QAM("C"),"^",QAM)="" G:X'[$P(QAM("C"),"^",QAM) XBAD1
- XOK1 SET X=""
- SET @^%ZOSF("TRAP")
- SET X=QAM("X")
- KILL QAM
- GOTO 1
- XBAD1 SET X=""
- SET @^%ZOSF("TRAP")
- KILL QAM,X
- 1 FOR QAM=0:0
- SET QAM=$ORDER(^QA(743,D0,"COND",QAM))
- if QAM'>0
- QUIT
- KILL @("C"_QAM)
- +1 QUIT
- EN2 ; *** DISPLAY HELP SCREEN OF CONDITIONS
- +1 ; *** USED BEFORE EDIT OF FALL OUT RELATIONSHIP FIELD (743,25)
- +2 if $DATA(^QA(743,DA,"COND",0))[0
- QUIT
- if $PIECE(^(0),"^",4)'>0
- QUIT
- +3 WRITE !!?3,"CODE",?15,"CONDITION",!?2,"------",?14,"-----------"
- +4 FOR QAMD1=0:0
- SET QAMD1=$ORDER(^QA(743,DA,"COND",QAMD1))
- if QAMD1'>0
- QUIT
- SET QAM=$SELECT($DATA(^QA(743,DA,"COND",QAMD1,0))#2:+^(0),1:0)
- SET QAM=$SELECT($DATA(^QA(743.3,QAM,0))#2:$PIECE(^(0),"^"),1:"")
- WRITE !?3,$JUSTIFY("C"_QAMD1,3),?15,QAM
- +5 WRITE !
- +6 QUIT
- EN3 ; *** ASK PARAMETERS ON CONDITIONS
- +1 ; *** USED BY ALL EDITS ON THE CONDITION MULTIPLE
- +2 KILL Y
- +3 SET QAM=+$SELECT($DATA(^QA(743,QAMD0,"COND",QAMD1,0))#2:^(0),1:0)
- if QAM'>0
- QUIT
- +4 if $PIECE($GET(^QA(743.3,QAM,0)),"^",2)'>0
- QUIT
- +5 SET QAMPCODE=$SELECT($DATA(^QA(743.3,QAM,"PARM"))#2:^("PARM"),1:"")
- if QAMPCODE=""
- QUIT
- +6 SET X=$PIECE(QAMPCODE,"^",$LENGTH(QAMPCODE,"^"))
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- XECUTE QAMPCODE
- +7 QUIT
- EN4 ; *** CHECKS FOR A VALID RELATIONSHIP AMONG THE CONDITIONS
- +1 ; *** USED BY FIELD: 743,26
- +2 if '$DATA(^QA(743,D0,"COND","AS",1))
- QUIT
- +3 NEW C
- SET QAM("X")=X
- if $TRANSLATE(X,"(C!'&0123456789)")]""
- GOTO XBAD4
- if X?1.N
- GOTO XBAD4
- +4 SET X="I "_QAM("X")
- DO ^DIM
- if '$DATA(X)
- GOTO XBAD4
- SET QAM("C")=""
- +5 FOR QAM=0:0
- SET QAM=$ORDER(^QA(743,D0,"COND",QAM))
- if QAM'>0
- QUIT
- IF $PIECE(^QA(743,D0,"COND",QAM,0),"^",2)
- SET @("C"_QAM_"=1")
- SET QAM("C")=QAM("C")_"C"_QAM_"^"
- +6 SET X="XBAD4^QAMUTL0"
- SET @^%ZOSF("TRAP")
- SET X="I "_QAM("X")
- XECUTE X
- +7 ;F QAM=1:1 Q:$P(QAM("C"),"^",QAM)="" G:X'[$P(QAM("C"),"^",QAM) XBAD4
- XOK4 SET X=""
- SET @^%ZOSF("TRAP")
- SET X=QAM("X")
- KILL QAM
- GOTO 4
- XBAD4 SET X=""
- SET @^%ZOSF("TRAP")
- KILL QAM,X
- 4 FOR QAM=0:0
- SET QAM=$ORDER(^QA(743,D0,"COND",QAM))
- if QAM'>0
- QUIT
- KILL @("C"_QAM)
- +1 QUIT
- EN5 ; *** DISPLAY HELP SCREEN OF CONDITIONS
- +1 ; *** USED BEFORE EDIT OF SAMPLE RELATIONSHIP FIELD (743,26)
- +2 if $DATA(^QA(743,DA,"COND",0))[0
- QUIT
- if $PIECE(^(0),"^",4)'>0
- QUIT
- if '$DATA(^QA(743,DA,"COND","AS",1))
- QUIT
- +3 WRITE !!?3,"CODE",?15,"CONDITION",!?2,"------",?14,"-----------"
- +4 FOR QAMD1=0:0
- SET QAMD1=$ORDER(^QA(743,DA,"COND",QAMD1))
- if QAMD1'>0
- QUIT
- SET QAM=$SELECT($DATA(^QA(743,DA,"COND",QAMD1,0))#2:^(0),1:0)
- IF $PIECE(QAM,"^",2)
- SET QAM=$SELECT($DATA(^QA(743.3,+QAM,0))#2:$PIECE(^(0),"^"),1:"")
- WRITE !?3,$JUSTIFY("C"_QAMD1,3),?15,QAM
- +5 WRITE !
- +6 QUIT
- EN6 ; *** MOST RECENT PATIENT MOVEMENT (FILE #405)
- +1 ; *** USED AS DATA BY FIELD 743.4,40
- +2 ; PUT MOST DESIRED TRANSACTION TYPES AT THE BEGINNING OF QAMXREF E.G.
- +3 ; QAMXREF="6^2^1^3" SCAN: SPECIALTY XFR, WARD XFR, ADMISSION, DISCHARGE
- +4 SET QAMDTPT(1)=0
- if $DATA(QAMXREF)[0
- QUIT
- +5 FOR QA=1:1:$LENGTH(QAMXREF,"^")
- SET QA(0)=$PIECE(QAMXREF,"^",QA)
- SET QAM=+$ORDER(^DGPM("ATID"_QA(0),QAMDFN,9999999.9999998-QAMEVENT))
- SET QAMDTPT(1)=+$ORDER(^DGPM("ATID"_QA(0),QAMDFN,QAM,0))
- if QAMDTPT(1)
- QUIT
- +6 KILL QAMXREF
- QUIT
- EN7 ; *** SCREEN FOR OTHER DATA TO CAPTURE, USED BY FIELD 743,30
- +1 IF 0
- +2 FOR QA=0:0
- SET QA=$ORDER(^QA(743.3,"AELEM",+Y,QA))
- if QA'>0
- QUIT
- IF $ORDER(^QA(743,D0,"COND","B",QA,0))>0
- QUIT
- +3 KILL QA
- QUIT
- EN8 ; *** INPUT TRANSFORM FOR GROUP MEMBER SUB-FIELD 743.51,.01
- +1 NEW D,DIC,DICR,DIX,DO,Y
- SET X=$SELECT(X[";":$PIECE(X,";"),1:X)
- SET Y=-1
- SET DIC(0)="EMQZ"
- SET DIC=$SELECT($DATA(^QA(743.5,DA(1),0))#2:+$PIECE(^(0),"^",2),1:0)
- SET DIC=$SELECT($DATA(^DIC(DIC,0,"GL"))#2:^("GL"),1:"")
- if DIC=""
- GOTO 8
- DO DO^DIC1
- DO ^DIC
- SET X=$SELECT($DATA(Y(0,0))#2:Y(0,0)_";"_+Y,1:"")
- 8 if Y'>0
- KILL X
- QUIT
