- DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 10/15/12
- ;
- S DIKZK=1
- S DIKZ(0)=$G(^DGMT(408.31,DA,0))
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" S ^DGMT(408.31,"B",$E(X,1,30),DA)=""
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2)&($P(^(0),U,3))&($P(^(0),U,19)) ^DGMT(408.31,"AS",+$P(^(0),U,19),+$P(^(0),U,3),-X,+$P(^(0),U,2),DA)=""
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2)&($P(^(0),U,19)) ^DGMT(408.31,"AID",+$P(^(0),U,19),+$P(^(0),U,2),-X,DA)=""
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2)&($P(^(0),U,19)) ^DGMT(408.31,"AD",+$P(^(0),U,19),+$P(^(0),U,2),X,DA)=""
- S X=$P($G(DIKZ(0)),U,1)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2) ^DGMT(408.31,"ADFN"_$P(^(0),U,2),X,DA)=""
- S X=$P($G(DIKZ(0)),U,19)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2)&($P(^(0),U,3)) ^DGMT(408.31,"AS",X,+$P(^(0),U,3),-$P(^(0),U),+$P(^(0),U,2),DA)=""
- S X=$P($G(DIKZ(0)),U,19)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2) ^DGMT(408.31,"AID",X,+$P(^(0),U,2),-$P(^(0),U),DA)=""
- S X=$P($G(DIKZ(0)),U,19)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2) ^DGMT(408.31,"AD",X,+$P(^(0),U,2),$P(^(0),U),DA)=""
- S X=$P($G(DIKZ(0)),U,19)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGMT(408.31,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="9" X ^DD(408.31,.019,1,4,1.4)
- S DIKZ(0)=$G(^DGMT(408.31,DA,0))
- S X=$P($G(DIKZ(0)),U,2)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,3)&($P(^(0),U,19)) ^DGMT(408.31,"AS",$P(^(0),U,19),$P(^(0),U,3),-$P(^(0),U),X,DA)=""
- S X=$P($G(DIKZ(0)),U,2)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,19) ^DGMT(408.31,"AID",$P(^(0),U,19),X,-$P(^DGMT(408.31,DA,0),U),DA)=""
- S X=$P($G(DIKZ(0)),U,2)
- I X'="" S ^DGMT(408.31,"C",$E(X,1,30),DA)=""
- S X=$P($G(DIKZ(0)),U,2)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,19) ^DGMT(408.31,"AD",$P(^DGMT(408.31,DA,0),U,19),X,$P(^(0),U),DA)=""
- S X=$P($G(DIKZ(0)),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.31,.02,1,5,69.2) S Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGMT(408.31,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="1" X ^DD(408.31,.02,1,5,1.4)
- S X=$P($G(DIKZ(0)),U,2)
- I X'="" S ^DGMT(408.31,"ADFN"_X,+^DGMT(408.31,DA,0),DA)=""
- S DIKZ(0)=$G(^DGMT(408.31,DA,0))
- S X=$P($G(DIKZ(0)),U,3)
- I X'="" S:$P(^DGMT(408.31,DA,0),U,2)&($P(^(0),U,19)) ^DGMT(408.31,"AS",$P(^(0),U,19),X,-$P(^(0),U),+$P(^(0),U,2),DA)=""
- S X=$P($G(DIKZ(0)),U,3)
- I X'="" D CUR^DGMTDD
- S X=$P($G(DIKZ(0)),U,7)
- I X'="" S ^DGMT(408.31,"AG",$E(X,1,30),DA)=""
- S X=$P($G(DIKZ(0)),U,11)
- I X'="" D:$G(DGMTYPT)<3 AUTOUPD^DGENA2(+$P(^DGMT(408.31,DA,0),U,2),2)
- S X=$P($G(DIKZ(0)),U,16)
- I X'="" S ^DGMT(408.31,"AP",X,$P(^DGMT(408.31,DA,0),U),DA)=""
- S X=$P($G(DIKZ(0)),U,20)
- I X'="" S ^DGMT(408.31,"AE",$E(X,1,30),DA)=""
- S X=$P($G(DIKZ(0)),U,20)
- I X'="" S:'X $P(^DGMT(408.31,DA,0),U,21,22)="^"
- S DIKZ(2)=$G(^DGMT(408.31,DA,2))
- S X=$P($G(DIKZ(2)),U,2)
- I X'="" D E40831^DGRTRIG(DA)
- S X=$P($G(DIKZ(2)),U,8)
- I X'="" S ^DGMT(408.31,"AT",$E(X,1,30),DA)=""
- END Q
- DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 10/15/12
- +1 ;
- +2 SET DIKZK=1
- +3 SET DIKZ(0)=$GET(^DGMT(408.31,DA,0))
- +4 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +5 IF X'=""
- SET ^DGMT(408.31,"B",$EXTRACT(X,1,30),DA)=""
- +6 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +7 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)&($PIECE(^(0),U,3))&($PIECE(^(0),U,19))
- SET ^DGMT(408.31,"AS",+$PIECE(^(0),U,19),+$PIECE(^(0),U,3),-X,+$PIECE(^(0),U,2),DA)=""
- +8 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +9 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)&($PIECE(^(0),U,19))
- SET ^DGMT(408.31,"AID",+$PIECE(^(0),U,19),+$PIECE(^(0),U,2),-X,DA)=""
- +10 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +11 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)&($PIECE(^(0),U,19))
- SET ^DGMT(408.31,"AD",+$PIECE(^(0),U,19),+$PIECE(^(0),U,2),X,DA)=""
- +12 SET X=$PIECE($GET(DIKZ(0)),U,1)
- +13 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)
- SET ^DGMT(408.31,"ADFN"_$PIECE(^(0),U,2),X,DA)=""
- +14 SET X=$PIECE($GET(DIKZ(0)),U,19)
- +15 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)&($PIECE(^(0),U,3))
- SET ^DGMT(408.31,"AS",X,+$PIECE(^(0),U,3),-$PIECE(^(0),U),+$PIECE(^(0),U,2),DA)=""
- +16 SET X=$PIECE($GET(DIKZ(0)),U,19)
- +17 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)
- SET ^DGMT(408.31,"AID",X,+$PIECE(^(0),U,2),-$PIECE(^(0),U),DA)=""
- +18 SET X=$PIECE($GET(DIKZ(0)),U,19)
- +19 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)
- SET ^DGMT(408.31,"AD",X,+$PIECE(^(0),U,2),$PIECE(^(0),U),DA)=""
- +20 SET X=$PIECE($GET(DIKZ(0)),U,19)
- +21 IF X'=""
- Begin DoDot:1
- +22 NEW DIK,DIV,DIU,DIN
- +23 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- SET Y(0)=X
- SET X=Y(0)
- SET X=X
- SET X=X=2
- IF X
- SET X=DIV
- SET Y(1)=$SELECT($DATA(^DGMT(408.31,D0,0)):^(0),1:"")
- SET X=$PIECE(Y(1),U,3)
- SET X=X
- SET DIU=X
- KILL Y
- SET X=DIV
- SET X="9"
- XECUTE ^DD(408.31,.019,1,4,1.4)
- End DoDot:1
- +24 SET DIKZ(0)=$GET(^DGMT(408.31,DA,0))
- +25 SET X=$PIECE($GET(DIKZ(0)),U,2)
- +26 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,3)&($PIECE(^(0),U,19))
- SET ^DGMT(408.31,"AS",$PIECE(^(0),U,19),$PIECE(^(0),U,3),-$PIECE(^(0),U),X,DA)=""
- +27 SET X=$PIECE($GET(DIKZ(0)),U,2)
- +28 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,19)
- SET ^DGMT(408.31,"AID",$PIECE(^(0),U,19),X,-$PIECE(^DGMT(408.31,DA,0),U),DA)=""
- +29 SET X=$PIECE($GET(DIKZ(0)),U,2)
- +30 IF X'=""
- SET ^DGMT(408.31,"C",$EXTRACT(X,1,30),DA)=""
- +31 SET X=$PIECE($GET(DIKZ(0)),U,2)
- +32 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,19)
- SET ^DGMT(408.31,"AD",$PIECE(^DGMT(408.31,DA,0),U,19),X,$PIECE(^(0),U),DA)=""
- +33 SET X=$PIECE($GET(DIKZ(0)),U,2)
- +34 IF X'=""
- Begin DoDot:1
- +35 NEW DIK,DIV,DIU,DIN
- +36 KILL DIV
- SET DIV=X
- SET D0=DA
- SET DIV(0)=D0
- SET Y(0)=X
- XECUTE ^DD(408.31,.02,1,5,69.2)
- SET Y=X
- SET X=Y(2)
- SET X=X&Y
- IF X
- SET X=DIV
- SET Y(1)=$SELECT($DATA(^DGMT(408.31,D0,0)):^(0),1:"")
- SET X=$PIECE(Y(1),U,3)
- SET X=X
- SET DIU=X
- KILL Y
- SET X=DIV
- SET X="1"
- XECUTE ^DD(408.31,.02,1,5,1.4)
- End DoDot:1
- +37 SET X=$PIECE($GET(DIKZ(0)),U,2)
- +38 IF X'=""
- SET ^DGMT(408.31,"ADFN"_X,+^DGMT(408.31,DA,0),DA)=""
- +39 SET DIKZ(0)=$GET(^DGMT(408.31,DA,0))
- +40 SET X=$PIECE($GET(DIKZ(0)),U,3)
- +41 IF X'=""
- IF $PIECE(^DGMT(408.31,DA,0),U,2)&($PIECE(^(0),U,19))
- SET ^DGMT(408.31,"AS",$PIECE(^(0),U,19),X,-$PIECE(^(0),U),+$PIECE(^(0),U,2),DA)=""
- +42 SET X=$PIECE($GET(DIKZ(0)),U,3)
- +43 IF X'=""
- DO CUR^DGMTDD
- +44 SET X=$PIECE($GET(DIKZ(0)),U,7)
- +45 IF X'=""
- SET ^DGMT(408.31,"AG",$EXTRACT(X,1,30),DA)=""
- +46 SET X=$PIECE($GET(DIKZ(0)),U,11)
- +47 IF X'=""
- IF $GET(DGMTYPT)<3
- DO AUTOUPD^DGENA2(+$PIECE(^DGMT(408.31,DA,0),U,2),2)
- +48 SET X=$PIECE($GET(DIKZ(0)),U,16)
- +49 IF X'=""
- SET ^DGMT(408.31,"AP",X,$PIECE(^DGMT(408.31,DA,0),U),DA)=""
- +50 SET X=$PIECE($GET(DIKZ(0)),U,20)
- +51 IF X'=""
- SET ^DGMT(408.31,"AE",$EXTRACT(X,1,30),DA)=""
- +52 SET X=$PIECE($GET(DIKZ(0)),U,20)
- +53 IF X'=""
- IF 'X
- SET $PIECE(^DGMT(408.31,DA,0),U,21,22)="^"
- +54 SET DIKZ(2)=$GET(^DGMT(408.31,DA,2))
- +55 SET X=$PIECE($GET(DIKZ(2)),U,2)
- +56 IF X'=""
- DO E40831^DGRTRIG(DA)
- +57 SET X=$PIECE($GET(DIKZ(2)),U,8)
- +58 IF X'=""
- SET ^DGMT(408.31,"AT",$EXTRACT(X,1,30),DA)=""
- END QUIT
